﻿Option Explicit On
Imports Microsoft.Office.Interop.Excel
Imports Microsoft.Office.Interop


Module Module1
    Public appExcel As Application

    Public Function ConnectToQC(ByVal strServerName, ByVal strDomain, ByVal strProject, ByVal strUserName, ByVal strPassword)
        Dim strQCServer As String
        Dim QCConnection As Object
        strQCServer = "http://" & strServerName & "/qcbin"
        'MsgBox("QCServer = " & strQCServer)
        Try
            QCConnection = CreateObject("TDApiOle80.TDConnection")
            QCConnection.InitConnectionEx(strQCServer)
            QCConnection.login(strUserName, strPassword)
            QCConnection.Connect(strDomain, strProject)
        Catch ex As Exception
            MsgBox("Can't connect to QC Server. If remote, ensure VPN is running. " & ex.Message)
            QCConnection = Nothing
            Form1.Close()
        End Try
        ConnectToQC = QCConnection
    End Function


    Public Sub queryExcel(ByRef strServerName, ByRef strDomain, ByRef strProject, ByRef strUserName, ByRef strPassword, ByRef arFieldNames())
        ' appExcel = New Excel.Application
        appExcel = CreateObject("Excel.Application")
        ' Connect to the Quality Center Server.
        Dim QCConnection
        QCConnection = ConnectToQC(strServerName, strDomain, strProject, strUserName, strPassword)
        
        '''''''''''''''''''''''''''''''''''''''''''''
        ' Open a new Excel worksheet.
        Dim NewBook As Excel.Workbook
        Dim Sheet As Excel.Worksheet
        Dim objCommand, RecSet, objCommand1, RecSet1
        Dim strName, sDate As String
        appExcel.Visible = True
        NewBook = appExcel.Workbooks.Add()
        Sheet = NewBook.ActiveSheet
        'Set column widths and wordwrap
        Sheet.Columns("A:A").ColumnWidth = 10
        Sheet.Columns("B:D").ColumnWidth = 50
        Sheet.Cells.WrapText = True
        ' Set the column names.
        Sheet.Cells(1, 1).Value = arFieldNames(1)
        Sheet.Cells(1, 2).Value = arFieldNames(2)
        Sheet.Cells(1, 3).Value = arFieldNames(3)
        Sheet.Cells(1, 4).Value = arFieldNames(4)
        ' Retrieve the values of each Req.
        Dim Row
        Row = 2
        strName = ""
        objCommand = QCConnection.Command
        objCommand.CommandText = "SELECT " & arFieldNames(1) & ", " & arFieldNames(2) & ", " & arFieldNames(3) & ", " & arFieldNames(4) & " FROM " & arFieldNames(0)
        'MsgBox("SELECT " & arFieldNames(1) & ", " & arFieldNames(2) & ", " & arFieldNames(3) & ", " & arFieldNames(4) & " FROM " & arFieldNames(0))
        RecSet = objCommand.Execute
        RecSet.First()
        For i = 1 To RecSet.RecordCount
            Sheet.Cells(Row, 1).Value = RecSet.FieldValue((arFieldNames(1)))
            Sheet.Cells(Row, 2).Value = RecSet.FieldValue((arFieldNames(2)))
            Sheet.Cells(Row, 3).Value = RecSet.FieldValue((arFieldNames(3)))
            Sheet.Cells(Row, 4).Value = RecSet.FieldValue((arFieldNames(4)))

            Row = Row + 1
            RecSet.Next()
        Next
        objCommand = Nothing
        objCommand1 = Nothing
        RecSet = Nothing
        RecSet1 = Nothing

        '''''''''''''''''''''''''''''''''''''''''''''

        ' Save the result.
        Dim dToday As Date
        dToday = DateValue(Now)
        sDate = Format(dToday, "mmm-dd-yy")
        ChDir("c:\")
        Dim fileType As XlFileFormat, strError
        fileType = XlFileFormat.xlOpenXMLWorkbook
        Try
            NewBook.SaveAs(Filename:="c:\QualityCenter_Demo_REQS" & sDate & ".xlsx", FileFormat:= _
                fileType, CreateBackup:=True)
        Catch ex As Exception
            MsgBox("Spreadsheet not saved. Please rename and save the spreadsheet by hand before closing.")
        End Try

        ' Cleanup.

        MsgBox("Project data download complete.", 4096, "Done")
        QCConnection = Nothing

        'appExcel.Quit

    End Sub

End Module
